home *** CD-ROM | disk | FTP | other *** search
Text File | 1990-06-25 | 77.2 KB | 1,638 lines | [ TEXT/CCL ]
; (c) Copyright 1990 by University of Massachusetts. All rights reserved. ; This software was conceived, designed, and written by Dan Suthers ; while supported by the National Science Foundation under grant number ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino, ; CA. Partial support was also received from the Office of Naval Research ; under a University Research Initiative Grant, contract N00014-86-K-0764. ; Mr. Suthers created this software under his own initiative while in an ; academic relationship with the University of Massachusetts. The above ; copyright notice was a condition placed by University lawyers on approval ; of distribution of this software by Apple Computer, and is not meant to ; imply that this software was created in an employment or "work for hire" ; relationship between the University and Mr. Suthers. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; File: SMEDIT.LISP ; Author: Dan Suthers ; Created: 01-Jan-88 22:55:00 ; Modified: 22-Jun-90 02:13:23 (Dan Suthers) ; Language: LISP ; Package: SM ; ; Description: Frame browser and editor for SM (see documentation below). ; CORAL ALLEGRO COMMON LISP VERSION FOR THE MACINTOSH. ; ; (c) Copyright 1988, by Daniel D. Suthers ; Department of Computer and Information Science ; University of Massachusetts ; Amherst, Massachusetts 01003 ; ; This software was conceived, designed, and written by Dan Suthers ; while supported by the National Science Foundation under grant number ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino, ; CA. Partial support was also received from the Office of Naval Research ; under a University Research Initiative Grant, contract N00014-86-K-0764. ; I wish to acknowledge the generous support of Beverly Woolf, who obtained ; the above grants and encouraged me to pursue my own research interests in ; her lab. This work would not have been possible without the resources and ; stimulating environment of the Computer and Information Science department. ; ; Permission to use, modify, and distribute this software is granted subject ; to the following restrictions and understandings: ; 1. The file header, including this notice, shall be retained, and may be ; extended to include documentation of modifications to the software. ; 2. This material is for nonprofit educational and research purposes only. ; Users are requested, but not required, to inform Mr. Suthers of any ; noteworthy uses of this software. ; 3. Mr. Suthers and the University of Massachusetts make no warrantee or ; representation that the operation of this software will be error free, ; and are under no obligation to provide any services. ; 4. Any user of such software agrees to indemnify and hold harmless Mr. ; Suthers and the University of Massachusetts from all claims arising ; out of the use or misuse of this software, or arising out of any ; accident, injury, or damage whatsoever, and from all costs, counsel ; fees, and liabilities incurred in or about any such claim, action, or ; proceeding brought thereon. ; 5. All materials and reports developed as a consequence of the use of ; this software shall duly acknowledge such use, in accordance with ; the usual standards of acknowledging credit in academic research. ; ; Status: Tested and presumed usable 30-Jan-90 ; ; Changes: ; ; 31-Jan-88 Using :summary and :brief styles as appropriate; default path ; and extension for instance files. Edit-struct-actions associates types ; with (lambda (instance editor) ...) to alter edit buffer. ; 03-Feb-88 Make new instance names in same package as type. ; 04-Feb-88 Edit-struct makes windows wide enough for titles if the title is ; larger than the macro columns. ; 10-Feb-88 Selection of instance no longer pops up previous edit window: this ; was annoying. Now must select edit. Also added choose-file-dialogs. ; 11-Feb-88 Moving buttons around. Selection of instance reminds you if edit ; window is up. ; 26-Feb-88 Made it machine-independent with file-I/O on those machines not ; supporting windows. ; 19-Apr-88 Converted to SM (rename of KR0); also renamed edit-struct -> edits. ; 10-May-88 Updating for new SM. ; 20-Jun-88 Displays type information when type selected. ; 29-Jun-88 More save-type and save-instance options now user selectable; ; improvements in browser display. ; 03-Jul-88 Inspect and Style buttons added. Using new COPIES for copying. ; Small browser reorganized to have Inspect button. ; 13-Jul-88 Updated for new SM slots and type editing capabilities. ; 19-Jul-88 Added Go To button for following links via slots. Also ; each browser has its own prints style. ; 24-Jul-88 Flush Freelist on menu. Fred windows no longer scratch, but ; destroy-sm-editor-windows-of-type ignores mod-flag. Added close button. ; 30-Jul-88 Edit Slot added, close button moved to menu. ; 25-Oct-88 Pretty printing type definitions when editing them. When ; saving instances all instances of a type from the menu, edits windows ; go away when done. This lets them serve as indicators when there is ; in-memory stuff to save. ; 01-Nov-88 When creating a browser, you can specify the title and which ; classes are displayed. EDITS now refers to type option :after-edit ; to get its edit actions. Browser no longer sorts instance names, ; since user will have specified :sort-instances if this is important. ; 11-Nov-88 Fixed error when deleting last instance of a type in browser. ; 13-Nov-88 :Before-edit option added. ; 16-Nov-88 SAVE-TYPE-PARAMETER-DIALOGUE supports added :append option. ; Order of returned values changed to be consistent with menu ordering. ; 01-Dec-88 DESTROY-SM-EDITOR-WINDOWS-OF-TYPE now has :ask-user option. ; 17-Dec-88 EDITS now puts up windows in package specified by type option ; :edit-in-package, or in that of the instance name (instead of the type). ; NEW-INSTANCE-NAME now uses UTILS:UNIQUE-SYMBOL. ; 31-Dec-88 Updated warning due to change to COPIES, which now copies conses. ; 11-Jan-88 Menu Flush Freelist now changed to Freelist Manager ; 14-Sep-89 Fixed extra quote error in New Type template, and allowing ; new types on load-type menu option. -- DS ; 25-Oct-89 Exporting find-editor-window, useful elsewhere. -- DS ; 29-Oct-89 SAVE-TYPE-PARAMETER-DIALOGUE defaults inclusion of type ; definition according to type option :save-type-definition. ; Save Type menu option destroys Edits windows when done. -- DS ; 07-Nov-89 Wrote menu-item-update for warn of redefinitions menu item. ; 30-Jan-90 Update for version 1.3.1: :default-button now in button items. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; CORAL ALLEGRO COMMON LISP VERSION: ; ; MENU: ; ; A menu is created which includes options to: ; - Activate BROWSE-STRUCT (described below) for mouse-driven browsing, ; - Toggle *warn-of-redefinitions*. ; - Close all EDITS windows of a specified type. ; - Edit the type definition. ; - Invoke SM operations of RESET-TYPE, DESTROY-TYPE, ; RESET-ALL-TYPES, DESTROY-ALL-TYPES, LOAD-TYPE, ; and SAVE-TYPE. ; ; BROWSE-STRUCT: ; ; The primary means of accessing SM instances, this creates a window ; with two scrollable menus for choice of type and instance, a display ; window for viewing pretty printed representations of instances, and ; various buttons for operating on instances. ; ; When a TYPE is selected in the type menu, all the instances of the ; type are listed in the instance scrollable menu. ; ; When an INSTANCE is selected, it is displayed in the display window. ; If an editor window exists for the object, a message notes this fact. ; Note that while the display window is Macintosh "editable text", and ; the user may alter the displayed text, this has no effect on the ; instance. I used the editable text dialog item simply because it ; draws a box around the text, and use of arrow keys allows the user to ; see text which is too big to fit in the box. Potential confusion about ; whether editing this representation has an effect may be averted by ; printing only non-readable forms in this window. ; ; The EDIT button creates a Fred window with the macro representation ; of an instance, such that the buffer may be evaluated after editing ; to redefine the instance. If such a window already exists, it is ; selected. Type options :before-edit and :after-edit are checked to ; determine what forms should be inserted in the editor buffer before ; and after the instance representation, respectively. These options ; should be lambdas of one argument to be given the instance name. ; ; SLOT-EDIT puts up an editor buffer with a form that lets you SETF ; the value of one slot of the instance after editing. This is useful ; for altering values of :COMPUTED slots (which don't appear in EDITS ; buffers). ; ; The COPY button makes a copy of the instance under a new instance name ; provided by the user. It uses COPIES, so read-only slots are copied. The ; macro representation of the instance is brought up in an edit window. ; ; NEW creates a new instance with default slot values, bringing up its ; macro representation in an edit window. The user is asked for a name. ; ; GOTO allows one to browse through a network of instances. It asks you what ; slot of the current instance contains the name(s) of other instances. If ; the value of this slot is a symbol, it is assumed to be the name of another ; instance of the same type, and this instance becomes the current instance ; and is displayed in the browser. If the slot contains a list, a menu is put ; up allowing you to select an element of the list. Processing of the selected ; element depends on whether it is a symbol or a list, and is as just stated. ; ; STYLE allows you to select which PRINTS style to use to display instances in ; the current browser. ; ; INSPECT invokes the inspector on the currently selected object. If a type ; is selected but no instance, the structure-type structure (which records ; definitional information) for that type is inspected. If an instance is ; selected, its structure is inspected. ; ; The DESTROY button destroys the selected instance (using destroys). ; ; Design Principles: ; ; o Buttons are only enabled when they are applicable and safe: ; - Style is always enabled. ; - New and Inspect are enabled only when a type is selected. ; - Edit, Slot-Edit, Copy, Goto, and Destroy are enabled only when an ; instance is selected. ; Exception is due to a fault in the dialog sequence items: when a null ; cell is selected, no action is executed, so I cannot deselect the buttons ; when the user deselects a type or instance. To avoid problems, the ; buttons watch for null type or instance. ; ; o Duplicate or inconsistent displays are avoided. ; - Re-editing an object causes its existing edit window to come up. ; - Selecting an object for viewing results in a reminder that the ; object is in an edit window, printed before the viewing representation. ; - If a menu action makes a change which invalidates the structure browser ; display, such as resetting or destroying a type, all existing structure ; browsers are destroyed. ; - If a type is destroyed from the menu, all windows displaying instances ; of that type are also destroyed. ; - If a single instance is destroyed, and an edit window exists for that ; instance, the window is destroyed. ; An exception: after SAVE-TYPE, all instance windows for the type are destroyed ; without confirmation. This allows instance windows to act as a "lock" against ; leaving lisp without saving the type, which is "unlocked" when it is saved. ; The only danger is that editing in unevaluated buffers will be lost. ; ; o The user has an opportunity to abort whenever an action will irretrievably ; destroy information. ; - Instance windows created by EDITS and type definition editing windows are ; not scratch windows, so Allegro puts up a confirmation dialogue when they ; are destroyed. ; - Confirmation is requested for DESTROYS, RESET-TYPE, etc. ; ; EDITS: ; ; This has syntax similar to sm:prints (without the stream or style), ; and creates a window with an evaluatable macro representation to edit. ; It is used by browse-struct, and may be useful for other code. See its ; documentation if needed. ; ; The :BEFORE-EDIT and :AFTER-EDIT type options are handles for clients which ; may wish to execute instance-processing forms before or after editing. To ; use it, record under the :before-edit or :after-edit type option a lambda ; form which takes the instance name as argument and performs the actions. ; In the CCL version of SMEDIT, this is accomplished by inserting a funcall ; of the :before-edit and :after-edit forms into the beginning and end, ; respectively, of the buffer created by EDITS. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; UNFIXED GLITCHES & POSSIBLE IMPROVEMENTS: ; ; If an instance has a name of NIL, every time it is selected the browser ; will behave as if it just discovered that there is no selected instance. ; This is because tests for whether selected-instance is nil trigger calls ; to no-instance-selected-handler. Could probably work around this with ; multiple value returns (2nd value telling if this IS an instance name). ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :SM) (require :MISC ) ; for unique-symbol (require :DIALOGUE) (export '( *sm-menu* browse-structs destroy-structure-browsers destroy-sm-editor-windows-of-type edits find-editor-window next-window-position new-instance-name save-type-parameter-dialogue )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconstant *EDITOR-WINDOW-FONT* '("monaco" 9)) (defconstant *EDITOR-WINDOW-FONT-HEIGHT* (multiple-value-bind (a d w l) (ccl:font-info *editor-window-font*) (declare (ignore w l)) (+ a d 2))) (defvar *STRUCTURE-BROWSERS* nil) ; known browsers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; HELPER MACROS ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The following macros will make more sense after reading BROWSE-STRUCT. ;;; They are macros instead of functions to be in the active object's ;;; lexical environment. They are only needed at compile time (eval-when (compile eval) (defmacro NO-TYPE-SELECTED-HANDLER () '(progn ;; Empty the instances list (ccl:ask (third (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:set-table-sequence nil)) ;; Update display. (ccl:ask (fourth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:set-dialog-item-text "No Type selected.")) ;; Ask buttons to disable themselves. (ccl:ask ; edit (fifth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-disable)) (ccl:ask ; destroy (sixth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-disable)) (ccl:ask ; copy (seventh (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-disable)) (ccl:ask ; new (eighth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-disable)) (ccl:ask ; goto (ninth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-disable)) (ccl:ask ; inspect (tenth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-disable)) (ccl:ask ; slot edit (nth 11 (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-disable)))) (defmacro NO-INSTANCE-SELECTED-HANDLER (update-display?) `(progn ;; Update display if requested. ,@(if update-display? '((ccl:ask (fourth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:set-dialog-item-text "No instance selected.")))) ;; Ask buttons which require instance to disable. (ccl:ask ; edit (fifth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-disable)) (ccl:ask ; destroy (sixth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-disable)) (ccl:ask ; copy (seventh (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-disable)) (ccl:ask ; go to (ninth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-disable)) (ccl:ask ; slot edit (nth 11 (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-disable)))) ) ; end of eval-when ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; BROWSER ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun BROWSE-STRUCTS (&key (small nil) (types (structure-types)) (title "Structure Browser ")) "browse-structs &optional <small> [Function] Creates and returns a permanent structure browsing window, which includes menus for selection of type and instance, displays the selected instance, and allows editing, deletion, copying, and creation operations. Non-nil optional argument makes small browser." (declare (object-variable (ccl:*dialog-item* ccl:my-dialog))) (check-type types list) (check-type title string) (assert (every #'(lambda (ty) (member ty (structure-types))) types) (types) "Types argument must be a list of structure type names.") ;; Dialog items need to refer to each other recursively. They ;; do so by referencing the > position < of the desired item in ;; the dialog-items list of the dialog created. The let* is so ;; the browser dialog can refer back to the dialog items. (let* ( (*prints-style* (if small :brief :summary)) ;; Labels on the two menus. (labels (ccl:oneof ccl:*static-text-dialog-item* :dialog-item-font '("chicago" 12) :dialog-item-text (if small " Structure Type Instances" " Structure Type Instances"))) ;; Table to select structure type from. (type-menu (ccl:oneof ccl:*sequence-dialog-item* :dialog-item-size (if small (ccl:make-point 150 140) (ccl:make-point 200 140)) :dialog-item-position (ccl:make-point 6 22) :table-vscrollp t :table-hscrollp nil :visible-dimensions (ccl:make-point 1 5) :cell-size (if small (ccl:make-point 150 16) (ccl:make-point 200 16)) :table-sequence ;; Sort this because user may have given unsorted list. (sort (copy-list types) #'(lambda (x y) (string< (symbol-name x) (symbol-name y)))) :sequence-order :vertical :dialog-item-action #'(lambda () (declare (object-variable (ccl:*dialog-item* ccl:my-dialog))) (let ((selected-type (ccl:cell-contents (car (ccl:selected-cells))))) ;; Display information about the type. (ccl:ask (fourth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:set-dialog-item-text (if small (remove #\newline (or (type-info selected-type :comments) "Use large structure browser for information on this type and its slot definitions. Alternately, inspect the type.")) ;; This string takes some grinding, so do it only ;; once per type per session, and save. (or (get selected-type '$browser-doc-string$) (setf (get selected-type '$browser-doc-string$) (let ((*print-pretty* T)) (flet ((deconser (a+b) (list (car a+b) (cdr a+b)))) (format nil "~:@(---------- Structure Type ~S ----------~)~ ~%UNCOMPUTED SLOTS: ~A~ ~%COMPUTED SLOTS: ~A~ ~%READ ONLY SLOTS: ~A~ ~%REUSABLE: ~A; REPRESENTATION: ~A; INITIAL-OFFSET: ~A; NAMED: ~A~ ~%TYPE-INFO: ~S~ ~%SLOT INFO: ~{~& [~:@(~A:~) ~S]~}~ ~%SLOT DEFAULTS: ~{~& [~:@(~A:~) ~S]~}~ ~%SLOT TYPES: ~{~& [~:@(~A:~) ~S]~}" selected-type (uncomputed-slots selected-type) (computed-slots selected-type) (read-only-slots selected-type) (reusable selected-type) (representation selected-type) (initial-offset selected-type) (named selected-type) (type-info selected-type) ;; Extra work needed since format can't handle dots. (mapcan #'deconser (slot-info selected-type)) (mapcan #'deconser (slot-defaults selected-type)) (mapcan #'deconser (slot-types selected-type)))))))))) ;; List instances in instance menu. (ccl:ask (third (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:set-table-sequence (instances selected-type))) (no-instance-selected-handler nil) ;; Enable new and inspect buttons (ccl:ask ; new (eighth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-enable)) (ccl:ask ; inspect (tenth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-enable)))))) ;; Table to select instance from. (instance-menu (ccl:oneof ccl:*sequence-dialog-item* :dialog-item-size (if small (ccl:make-point 150 140) (ccl:make-point 200 140)) :dialog-item-position (if small (ccl:make-point 180 22) (ccl:make-point 230 22)) :table-vscrollp t :table-hscrollp nil :visible-dimensions (ccl:make-point 1 5) :cell-size (if small (ccl:make-point 150 16) (ccl:make-point 200 16)) :table-sequence nil :sequence-order :vertical :dialog-item-action #'(lambda () (declare (object-variable (ccl:*dialog-item* ccl:my-dialog))) (let* ((selected-instance (ccl:cell-contents (car (ccl:selected-cells)))) (selected-type (ccl:ask type-menu (if (ccl:selected-cells) (ccl:cell-contents (car (ccl:selected-cells)))))) (title nil) (window nil) (representation nil)) (if (null selected-type) (no-type-selected-handler) ;; Type is selected, process instance. (progn (setf title (prints selected-type selected-instance :style :name :stream nil) window (find-editor-window title) representation (prints selected-type selected-instance :style *prints-style* :stream nil)) ;; Display in non-edit window in browser, with reminder ;; if an edit window is up. (ccl:ask (fourth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:set-dialog-item-text (if window (format nil "***** ~A in Edit window *****~%~A" title representation) representation))) ;; Enable instance processing buttons. (ccl:ask ; edit (fifth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-enable)) (ccl:ask ; destroy (sixth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-enable)) (ccl:ask ; copy (seventh (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-enable)) (ccl:ask ; go to (ninth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-enable)) (ccl:ask ; slot edit (nth 11 (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-enable)))))))) ;; Region in which printed representation of instance is displayed. (display (ccl:oneof ccl:*editable-text-dialog-item* :dialog-item-size (if small (ccl:make-point 335 85) (ccl:make-point 590 200)) :dialog-item-position (ccl:make-point 8 114) :dialog-item-font '("monaco" 9) :dialog-item-text "Nothing Selected." :allow-returns t)) ;; Button for creating Fred window to edit selected instance. ;; Disabled unless an instance is selected. (edit-button (ccl:oneof ccl:*button-dialog-item* :dialog-item-text " Edit " :dialog-item-position (if small (ccl:make-point 362 11) (ccl:make-point 467 11)) :dialog-item-enabled-p nil :dialog-item-action #'(lambda () (let ((selected-instance (ccl:ask instance-menu (if (ccl:selected-cells) (ccl:cell-contents (car (ccl:selected-cells)))))) (selected-type (ccl:ask type-menu (if (ccl:selected-cells) (ccl:cell-contents (car (ccl:selected-cells))))))) (cond ((null selected-type) (no-type-selected-handler)) ((null selected-instance) (no-instance-selected-handler T)) ((EDITS selected-type selected-instance) ;; Update display. (ccl:ask display (ccl:set-dialog-item-text (format nil "~A in edit window." (prints selected-type selected-instance :style :name :stream nil)))))))))) ;; Button for destroying the instance selected. (destroy-button (ccl:oneof ccl:*button-dialog-item* :dialog-item-text "Destroy" :dialog-item-position (if small (ccl:make-point 353 186) (ccl:make-point 530 86)) :dialog-item-enabled-p nil :dialog-item-action #'(lambda () (declare (object-variable (ccl:*dialog-item* ccl:my-dialog))) (let* ((selected-instance (ccl:ask instance-menu (if (ccl:selected-cells) (ccl:cell-contents (car (ccl:selected-cells)))))) (selected-type (ccl:ask type-menu (if (ccl:selected-cells) (ccl:cell-contents (car (ccl:selected-cells)))))) (title nil)) (cond ((null selected-type) (no-type-selected-handler)) ((null selected-instance) (no-instance-selected-handler t)) (t ;; Get name of destroyed thing, before destroying. (setf title (prints selected-type selected-instance :style :name :stream nil)) (if (wind:y-or-n-dialogue (format nil "Destroy structure instance~&~A?" title)) (progn (destroys selected-type selected-instance) ;; Update instance list and display. (ccl:ask instance-menu (ccl:cell-deselect (first (ccl:selected-cells))) (ccl:set-table-sequence (instances selected-type)) (if (instances selected-type) (ccl:scroll-to-cell (ccl:index-to-cell 0)))) (ccl:ask display (ccl:set-dialog-item-text (format nil "~A destroyed." title))) ;; Disable buttons requiring instance. (ccl:ask ; edit (fifth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-disable)) (ccl:ask ; destroy (sixth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-disable)) (ccl:ask ; copy (seventh (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-disable)) (ccl:ask ; go to (ninth (ccl:ask ccl:my-dialog (ccl:dialog-items))) (ccl:dialog-item-disable)) ;; Destroy window if it exists. (let ((ew (find-editor-window title))) (if ew (ccl:ask ew (ccl:window-close)))))))))))) ;; Button for copying instance into new instance which is ;; brought up in Fred window (for copy + edit paradigm). (copy-button (ccl:oneof ccl:*button-dialog-item* :dialog-item-text " Copy " :dialog-item-position (if small (ccl:make-point 358 61) (ccl:make-point 464 61)) :dialog-item-enabled-p nil :dialog-item-action #'(lambda () (declare (object-variable (ccl:*dialog-item* ccl:my-dialog))) (let* ((selected-instance (ccl:ask instance-menu (if (ccl:selected-cells) (ccl:cell-contents (car (ccl:selected-cells)))))) (selected-type (ccl:ask type-menu (if (ccl:selected-cells) (ccl:cell-contents (car (ccl:selected-cells)))))) (new-instance nil)) (cond ((null selected-type) (no-type-selected-handler)) ((null selected-instance) (no-instance-selected-handler t)) ;; Nil is returned from new-instance-name if user cancels. ((setf new-instance (new-instance-name selected-type)) (copies selected-type selected-instance new-instance :copy-tree t) ;; Write important warning into browser. (ccl:ask display (ccl:set-dialog-item-text "WARNING: Only slot values which are conses are copied.")) ;; Update menu and edit so user can fill in slots. (ccl:ask instance-menu (ccl:cell-deselect (first (ccl:selected-cells))) (ccl:set-table-sequence (instances selected-type)) (ccl:scroll-to-cell (ccl:index-to-cell 0)) ; new instance (ccl:cell-select (ccl:index-to-cell 0))) (edits selected-type new-instance))))))) ;; Button to create a new instance of selected type. ;; (Instance need not be selected.) (new-button (ccl:oneof ccl:*button-dialog-item* :dialog-item-text " New " :dialog-item-position (if small (ccl:make-point 360 86) (ccl:make-point 466 86)) :dialog-item-enabled-p nil :dialog-item-action #'(lambda () (declare (object-variable (ccl:*dialog-item* ccl:my-dialog))) (let* ((selected-type (ccl:ask type-menu (if (ccl:selected-cells) (ccl:cell-contents (car (ccl:selected-cells)))))) (new-instance nil)) (cond ((null selected-type) (no-type-selected-handler)) ((setf new-instance (new-instance-name selected-type)) ;; Have a new name: create default instance (default ;; values provided by the <type> macro). (funcall (creator selected-type) new-instance) ;; Ask instance item to re-list instances (ccl:ask instance-menu (if (ccl:selected-cells) (ccl:cell-deselect (first (ccl:selected-cells)))) (ccl:set-table-sequence (instances selected-type)) (ccl:scroll-to-cell (ccl:index-to-cell 0)) ; new instance (ccl:cell-select (ccl:index-to-cell 0))) ;; Put up edit window. There should not be existing window. (edits selected-type new-instance) (ccl:ask display (ccl:set-dialog-item-text (format nil "New Instance ~S is in edit window." new-instance)))) ((ccl:ed-beep))))))) ;; Button for browsing a structure named in a slot of the selected structure. (go-to-button (ccl:oneof ccl:*button-dialog-item* :dialog-item-text " Go To " :dialog-item-position (if small (ccl:make-point 358 111) (ccl:make-point 534 11)) :dialog-item-enabled-p nil :dialog-item-action #'(lambda () (declare (object-variable (ccl:*dialog-item* ccl:my-dialog))) (let* ((selected-instance (ccl:ask instance-menu (if (ccl:selected-cells) (ccl:cell-contents (car (ccl:selected-cells)))))) (selected-type (ccl:ask type-menu (if (ccl:selected-cells) (ccl:cell-contents (car (ccl:selected-cells)))))) (instance-structure nil) (slots->values nil) (selected-slot nil) (slot-value nil) (go-to-instance nil) (go-to-type nil)) (cond ((null selected-type) (no-type-selected-handler)) ((null selected-instance) (no-instance-selected-handler t)) (T (setf instance-structure (gets selected-type selected-instance)) ;; only be concerned with slots having plausible contents. (setf slots->values (mapcan #'(lambda (s+a &aux value) (declare (cons s+a)) (setq value (funcall (cdr s+a) instance-structure)) (if (or (symbolp value) (listp value)) (list (cons (car s+a) value)))) (slot-access selected-type))) (setf selected-slot (wind:menu-dialogue (mapcar #'car slots->values) "Go To instance named in which slot of ~S?" selected-instance)) (setf slot-value (cdr (assoc selected-slot slots->values))) (setf go-to-instance (cond ((null slot-value) (ccl:ed-beep) (wind:message-dialogue "Slot ~A's value is NIL" selected-slot) nil) ((symbolp slot-value) slot-value) ;; only one choice ((and (listp slot-value) (null (cdr slot-value))) (car slot-value)) ;; Must dive into list, and possibly sublists. ((listp slot-value) (let ((current-list slot-value) (current-selected nil)) (loop (setq current-selected (wind:menu-dialogue current-list "Select an instance or sublist.")) (cond ((null current-selected) (ccl:ed-beep) (wind:message-dialogue "You have selected a NIL value.") nil) ((and (listp current-selected) (cdr current-selected)) ;; Dotted pairs are pulled apart to list. This ;; lets us do alists, but (a b . c) blows up. (if (listp (cdr current-selected)) (setq current-list current-selected) (setq current-list (list (car current-selected) (cdr current-selected))))) ((listp current-selected) (return (car current-selected))) (t (return current-selected)))))) (T (ccl:ed-beep) (wind:message-dialogue "Selected slot must contain a symbol naming the instance to go to, or a list of instance names.") nil))) (setf go-to-type (if (and go-to-instance (symbolp go-to-instance)) (let ((candidate-types (mapcan #'(lambda (st) (if (gets st go-to-instance) (list st))) (ccl:ask type-menu (ccl:table-sequence))))) (cond ((null candidate-types) (ccl:ed-beep) (wind:message-dialogue "~S is not the instance of any type!" go-to-instance) nil) ((null (cdr candidate-types)) (car candidate-types)) (t (wind:menu-dialogue candidate-types "~S is an instance of multiple types; choose which:" go-to-instance)))))) (when go-to-type ;; Update type selection. (ccl:ask type-menu (ccl:cell-deselect (first (ccl:selected-cells))) (ccl:cell-select (ccl:index-to-cell (position go-to-type (ccl:table-sequence)))) (ccl:scroll-to-cell (ccl:index-to-cell (position go-to-type (ccl:table-sequence))))) ;; Update instance selection and activate so it displays. (ccl:ask instance-menu (ccl:cell-deselect (first (ccl:selected-cells))) (ccl:set-table-sequence (instances go-to-type)) (ccl:cell-select (ccl:index-to-cell (position go-to-instance (ccl:table-sequence)))) (ccl:scroll-to-cell (ccl:index-to-cell (position go-to-instance (ccl:table-sequence)))) (ccl:dialog-item-action))))))))) ;; Inspecting an instance or a type (if no instance selected). (inspect-button (ccl:oneof ccl:*button-dialog-item* :dialog-item-text "Inspect" :dialog-item-position (if small (ccl:make-point 353 161) (ccl:make-point 530 61)) :dialog-item-enabled-p nil :dialog-item-action #'(lambda () (declare (object-variable (ccl:*dialog-item* ccl:my-dialog))) (let ((selected-instance (ccl:ask instance-menu (if (ccl:selected-cells) (ccl:cell-contents (car (ccl:selected-cells)))))) (selected-type (ccl:ask type-menu (if (ccl:selected-cells) (ccl:cell-contents (car (ccl:selected-cells))))))) (cond ((null selected-type) (no-type-selected-handler)) ((null selected-instance) (inspect (get selected-type '$structure-type$))) (T (inspect (sm:gets selected-type selected-instance)))))))) ;; Changing the style by which instances are printed in the large browser. (style-button (ccl:oneof ccl:*button-dialog-item* :dialog-item-text " Style " :dialog-item-position (if small (ccl:make-point 357 136) (ccl:make-point 534 36)) :dialog-item-enabled-p t :dialog-item-action #'(lambda () (setf *prints-style* (wind:menu-dialogue (if small '(:name :brief :summary) '(:name :brief :summary :pretty :macro :pretty-macro)) "Choose default printing style for this particular browser:"))))) ;; Button for creating Fred window to edit a particular slot. (sedit-button (ccl:oneof ccl:*button-dialog-item* :dialog-item-text "Slot Edit" :dialog-item-position (if small (ccl:make-point 352 36) (ccl:make-point 458 36)) :dialog-item-enabled-p nil :dialog-item-action #'(lambda () (declare (object-variable (ccl:*dialog-item* ccl:my-dialog))) (let ((selected-instance (ccl:ask instance-menu (if (ccl:selected-cells) (ccl:cell-contents (car (ccl:selected-cells)))))) (selected-type (ccl:ask type-menu (if (ccl:selected-cells) (ccl:cell-contents (car (ccl:selected-cells))))))) (cond ((null selected-type) (no-type-selected-handler)) ((null selected-instance) (no-instance-selected-handler T)) ((edit-slot selected-type selected-instance (wind:menu-dialogue (mapcar #'car (slot-access selected-type)) "Edit which slot of ~A ~A?" selected-type selected-instance)))))))) ;; Create the browser window itself, with unique name. Dialog ;; items must be listed in specified order for mutual reference. (browser (ccl:oneof ccl:*dialog* :window-title (format nil "~A ~A" title (1+ (length *structure-browsers*))) :window-position (if small (ccl:make-point 215 265) :centered) :window-size (if small (ccl:make-point 420 208) (ccl:make-point 605 325)) :window-type :tool :dialog-items (list labels ; first type-menu ; second instance-menu ; third display ; fourth edit-button ; fifth destroy-button ; sixth copy-button ; seventh new-button ; eigth go-to-button ; ninth inspect-button ; tenth style-button ; eleventh sedit-button) ; twelth :default-button nil))) ;; save browser to be auto-destroyed when type info invalidated. (push browser *structure-browsers*) browser)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; STRUCTURE EDITORS ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun EDIT-TYPE (type) "edit-type <type> [Function] Given the symbolic names of a type, creates a Fred window holding the DST expression that defines the type. This may be edited and evaluated to change the type. If <type> is undefined, a null DST is given. The buffer also has a form to close all instance editor windows of instances of the type, in case they become inconsistent. Returns the window, immediately after window creation." ;; Error checking. (check-type type symbol) (let ((*package* (if type (symbol-package type) (find-package "USER"))) (title (format nil "~A's Definition" (if type (symbol-name type) "New Type"))) (dst-string "") (width 0) (height 0) (the-editor nil)) (declare (string dst-string) (fixnum width height)) ;; Create the editor window, sized to fit the type definition. (setf dst-string (let ((*print-pretty* t) (*print-escape* t) (*print-circle* nil) (*print-case* :downcase) (*print-array* t) (ccl::*print-structure* t)) (if type (format nil ";;; Don't forget to specify whether to :redefine!~ ~%(setf sm:*warn-of-redefinitions* t)~ ~%(sm:dst ~A~{~& ~S~})" (prin1-to-string (second (defining-form type))) (cddr (defining-form type))) ";;; A template for you to fill in: (sm:dst (<new-type> (:redefine nil) (:reusable <t-or-nil>) (:sort-instances <t-or-nil>) (:before-edit (lambda (i) <actions on i>)) (:after-edit (lambda (i) <actions on i>)) (:after-load (lambda () <initialization actions>)) (:comments <string>)) (<slot-name> <default> :type <slottype> :read-only <t-or-nil> :computed <t-or-nil> :comments <string>) )"))) (multiple-value-bind (columns rows) (wind:message-size dst-string) (declare (integer columns rows)) (setf columns (max columns (+ 10 (length title)))) (setf width (min 580 (max 350 (* 7 columns)))) (setf height (min 300 (max 100 (cond ((< rows 4) (* (+ 4 *editor-window-font-height*) rows)) ((< rows 12) (* (+ 2 *editor-window-font-height*) rows)) (t (* *editor-window-font-height* rows))))))) (setf the-editor (ccl:oneof ccl:*fred-window* :window-title title :window-position (next-window-position width height) :window-size (ccl:make-point width height) :window-show t :window-font *editor-window-font* :window-type :document-with-zoom :close-box-p t :scratch-p nil ; trouble. :package *package*)) ;; Insert the macro representation, and expression to close instance windows. (ccl:buffer-insert (ccl:ask the-editor (ccl:window-buffer)) dst-string) (if type (ccl:buffer-insert (ccl:ask the-editor (ccl:window-buffer)) (format nil "~%(sm:destroy-sm-editor-windows-of-type '~S)~ ~%(setf (get '~S 'sm::$browser-doc-string$) nil)" type type))) (ccl:ask the-editor (ccl:window-update)) ;; Return result. the-editor)) (defun EDITS (type instance &key (omit nil)) "edits <type> <instance> &key :omit [Function] Given the symbolic names of a type and an instance of the type, creates a Fred window holding the pretty-macro printed version of the instance. This may be edited and evaluated to change the instance. It is an error if the type is not defined, but undefined instances are defined automatically with default slot contents. Returns the window, immediately after window creation." ;; Error checking and instance creation. (check-type type symbol) (check-type instance symbol) (check-type omit list) (assert (member type (structure-types)) (type) "Structure type ~S is not defined." type) (if (not (member instance (instances type))) (funcall (creator type) instance)) (let* ((*package* ;; Edit in package specified, or default to package of instance name, ;; unless it is keyword package, in which case we use type's package. (or (find-package (type-info type :edit-in-package)) (let ((ipkg (symbol-package instance))) (if (eq ipkg *keyword-package*) (symbol-package type) ipkg)))) (title (prints type instance :style :name :stream nil)) (the-editor (find-editor-window title)) (struct-string "") (width 0) (height 0)) (declare (string title struct-string) (fixnum width height)) (cond (the-editor ;; Window exists: just activate. (ccl:ask the-editor (ccl:window-select))) ;; None yet: Create the editor window, sized to fit the macro ;; representation, with the correct package. (t (setf struct-string (prints type instance :style :pretty-macro :omit omit :stream nil)) (multiple-value-bind (columns rows) (wind:message-size struct-string) (declare (integer columns rows)) (setf columns (max columns (+ 10 (length title)))) (setf width (min 580 (max 250 (* 7 columns)))) (setf height (min 300 (max 100 (cond ((< rows 4) (* (+ 4 *editor-window-font-height*) rows)) ((< rows 12) (* (+ 2 *editor-window-font-height*) rows)) (t (* *editor-window-font-height* rows))))))) (setf the-editor (ccl:oneof ccl:*fred-window* :window-title title :window-position (next-window-position width height) :window-size (ccl:make-point width height) :window-show t :window-font *editor-window-font* :window-type :document-with-zoom :close-box-p t :scratch-p nil :package *package*)) ;; Insert call to any additional actions needed before editing. (let ((action (type-info type :before-edit))) (when action (ccl:buffer-insert (ccl:ask the-editor (ccl:window-buffer)) (let ((*print-pretty* t)) (format nil ";---------- :before-edit actions: ---------~ ~%(FUNCALL ~% '~A ~% '~S)~ ~%;------------------------------------------~%" (prin1-to-string action) instance))) ;; Scroll the window past this garbage. (ccl:ask the-editor (ccl:set-mark (ccl:window-start-mark) (ccl:buffer-mark (ccl:ask the-editor (ccl:window-buffer))))))) ;; Insert the macro representation. (ccl:buffer-insert (ccl:ask the-editor (ccl:window-buffer)) struct-string) ;; Insert call to any additional actions needed after editing. (let ((action (type-info type :after-edit))) (if action (ccl:buffer-insert (ccl:ask the-editor (ccl:window-buffer)) (let ((*print-pretty* t)) (format nil "~%;---------- :after-edit actions: ----------~ ~%(FUNCALL ~% '~A ~% '~S)" (prin1-to-string action) instance))))) (ccl:ask the-editor (ccl:window-update)) ;; Record the window under the type, for auto-destroying. (Why don't I ;; use info slot here? Because the user may clobber it!) (push the-editor (get type '$SM-editor-windows$)))) ;; Return result. the-editor)) (defun EDIT-SLOT (type instance slot) "edit-slot <type> <instance> slot [Function] Given the names of a type, an instance of the type, and a slot, creates a Fred window holding a SETF expression which when evaluated will set the contents of the slot to its current value (which may be edited). Returns the window, immediately after window creation." ;; Error checking and instance creation. (check-type type symbol) (check-type instance symbol) (check-type slot symbol) (assert (member type (structure-types)) (type) "Structure type ~S is not defined." type) (assert (assoc slot (slot-access type)) (slot type) "Slot ~S is not defined for type ~S." slot type) (assert (sm:gets type instance) (instance type) "Instance ~S of type ~S does not exist." instance type) (let* ((*package* (symbol-package instance)) (title (format nil "~S-~S of ~S" type slot instance)) (slot-string "") (width 0) (height 0) (the-editor nil)) (declare (string title slot-string) (fixnum width height)) ;; Create the editor window, sized to fit the setf expression. (setf slot-string (let ((*print-pretty* T) (*print-escape* t) (*print-circle* nil) (*print-case* :upcase) (*print-array* t) (ccl::*print-structure* t) (slot-contents (funcall (cdr (assoc slot (slot-access type))) (sm:gets type instance)))) (format nil "(setf (~S-~A (sm:gets '~S '~S))~%'~A)" type slot type instance (prin1-to-string slot-contents)))) (multiple-value-bind (columns rows) (wind:message-size slot-string) (declare (integer columns rows)) (setf columns (max columns (+ 10 (length title)))) (setf width (min 580 (max 250 (* 7 columns)))) (setf height (min 300 (max 100 (cond ((< rows 4) (* (+ 4 *editor-window-font-height*) rows)) ((< rows 12) (* (+ 2 *editor-window-font-height*) rows)) (t (* *editor-window-font-height* rows))))))) (setf the-editor (ccl:oneof ccl:*fred-window* :window-title title :window-position (next-window-position width height) :window-size (ccl:make-point width height) :window-show t :window-font *editor-window-font* :window-type :document-with-zoom :close-box-p t :scratch-p t :package *package*)) ;; Insert the setf form. (ccl:buffer-insert (ccl:ask the-editor (ccl:window-buffer)) slot-string) (ccl:ask the-editor (ccl:window-update)) ;; Record the window under the type, for auto-destroying. (push the-editor (get type '$SM-editor-windows$)) ;; Return result. the-editor)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; HELPER FUNCTIONS ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun FIND-EDITOR-WINDOW (title) (dolist (fred-window (ccl:windows ccl:*fred-window*)) (if (string= title (ccl:ask fred-window (ccl:window-title))) (return-from find-editor-window fred-window)))) ;;; Generate new name interactively with user. (defun NEW-INSTANCE-NAME (type &aux (name nil)) "Given the name of a structure type, interactively gets a new instance name from the user, with suggested default a name created by gensym using the type name as prefix. Returns the symbol, or NIL if there is an error or cancel." (check-type type symbol) (assert (member type (structure-types)) (type) "Unknown type.") (catch :cancel ; for CCL but won't hurt otherwise (let ((*package* (symbol-package type))) ; read in same package (setf name (read-from-string (wind:get-string-default-dialogue (symbol-name (utils:unique-symbol (concatenate 'string (symbol-name type) "-"))) "Enter name of the new instance of type ~A:" type) nil :eof$)))) (cond ((or (not (symbolp name)) (eq name :eof$)) (wind:message-dialogue "Error in reading your input as a symbol.") (new-instance-name type)) ((member name (instances type)) (wind:message-dialogue "That name is already in use for ~A." type) (new-instance-name type)) (name))) (defvar *POPUP-POSITIONS* (let ((positions (list ;; Each element consists of a window position and two integers ;; which are the H and V upper bounds for window sizes using ;; the given position. (list (ccl:make-point 10 40) ; NOTE: change next-window-position (- ccl:*screen-width* 20) ; if changing these smallest values, (- ccl:*screen-height* 50)) ; to prevent infinite loop. (list (ccl:make-point 20 60) (- ccl:*screen-width* 30) (- ccl:*screen-height* 70)) (list (ccl:make-point 30 80) (- ccl:*screen-width* 40) (- ccl:*screen-height* 90)) (list (ccl:make-point 40 100) (- ccl:*screen-width* 50) (- ccl:*screen-height* 110)) (list (ccl:make-point 50 120) (- ccl:*screen-width* 60) (- ccl:*screen-height* 130)) (list (ccl:make-point 60 140) (- ccl:*screen-width* 70) (- ccl:*screen-height* 150)) (list (ccl:make-point 70 160) (- ccl:*screen-width* 80) (- ccl:*screen-height* 170)) (list (ccl:make-point 80 180) (- ccl:*screen-width* 90) (- ccl:*screen-height* 190)) (list (ccl:make-point 90 200) (- ccl:*screen-width* 100) (- ccl:*screen-height* 210))))) (setf (cdr (last positions)) positions)) "A CIRCULAR list of nicely overlapping popup positions.") (defun NEXT-WINDOW-POSITION (width height &aux pos-list) "Given the width and height of a window, returns a position at which the window may be placed which overlaps nicely with previous windows placed using this function, and is guaranteed to keep the window entirely on the screen, provided it is small enough." (check-type width integer) (check-type height integer) ;; The following is necessary to prevent infinite loops on big windows. (if (or (> width (- ccl:*screen-width* 20)) (> height (- ccl:*screen-height* 50))) (ccl:make-point 5 ccl:*menubar-bottom*) (loop (setf pos-list (pop *popup-positions*)) (if (and (<= width (second pos-list)) (<= height (third pos-list))) (return (first pos-list)))))) (defun DESTROY-STRUCTURE-BROWSERS () (loop (if (null *structure-browsers*) (return)) ;; Coral manual says to check wptr binding to see if the ;; user has already closed it. (ccl:ask (pop *structure-browsers*) (if (boundp 'ccl:wptr) (ccl:window-close))))) (defun DESTROY-SM-EDITOR-WINDOWS-OF-TYPE (type &key (ask-user nil)) (loop (if (null (get type '$SM-editor-windows$)) (return)) (ccl:ask (pop (get type '$SM-editor-windows$)) (if (boundp 'ccl:wptr) (if ask-user (ccl:window-close) ;; Trick to bypass the Fred window save-to-file dialogs. (funcall (ccl:ask ccl:*window* (symbol-function 'ccl:window-close)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; MENU ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun SAVE-TYPE-PARAMETER-DIALOGUE (type) "save-type-parameter-dialogue <type> [Function] Returns 4 values, each being T or Nil, indicating whether to compile the file, whether to write the DST type definition to the file, whether to let the user select which instances to save, and whether to append to an existing file instead of writing a new one." (let* ((compile-checkbox (ccl:oneof ccl:*check-box-dialog-item* :dialog-item-text "Compile File" :dialog-item-position (ccl:make-point 9 40) :dialog-item-size (ccl:make-point 99 16) :check-box-checked-p nil)) (typedef-checkbox (ccl:oneof ccl:*check-box-dialog-item* :dialog-item-text "Include Type Definition" :dialog-item-position (ccl:make-point 9 68) :dialog-item-size (ccl:make-point 171 16) :check-box-checked-p (type-info type :save-type-definition))) (select-checkbox (ccl:oneof ccl:*check-box-dialog-item* :dialog-item-text "Save Selected Instances" :dialog-item-position (ccl:make-point 9 96) :dialog-item-size (ccl:make-point 180 16) :check-box-checked-p nil)) (append-checkbox (ccl:oneof ccl:*check-box-dialog-item* :dialog-item-text "Append to Existing File" :dialog-item-position (ccl:make-point 9 124) :dialog-item-size (ccl:make-point 180 16) :check-box-checked-p nil)) (static-label (ccl:oneof ccl:*static-text-dialog-item* :dialog-item-text (format nil "Parameters for saving ~A:" type) :dialog-item-position (ccl:make-point 9 9) :dialog-item-size (ccl:make-point 280 16))) (ok-button (ccl:oneof ccl:*button-dialog-item* :dialog-item-text " OK " :dialog-item-position (ccl:make-point 243 48) :dialog-item-size (ccl:make-point 35 16) :dialog-item-action #'(lambda () (ccl:return-from-modal-dialog (values (ccl:ask compile-checkbox (ccl:check-box-checked-p)) (ccl:ask typedef-checkbox (ccl:check-box-checked-p)) (ccl:ask select-checkbox (ccl:check-box-checked-p)) (ccl:ask append-checkbox (ccl:check-box-checked-p))))) :default-button t)) (cancel-button (ccl:oneof ccl:*button-dialog-item* :dialog-item-text "Cancel" :dialog-item-position (ccl:make-point 235 83) :dialog-item-size (ccl:make-point 53 16) :dialog-item-action #'(lambda () (ccl:return-from-modal-dialog :cancel)))) (the-dialog (ccl:oneof ccl:*dialog* :window-title "Save Type Dialog" :window-position :centered :window-size (ccl:make-point 300 150) :window-type :double-edge-box :dialog-items (list static-label compile-checkbox typedef-checkbox select-checkbox append-checkbox ok-button cancel-button)))) (ccl:modal-dialog the-dialog))) (defparameter *SM-menu* (let* ((line-item (ccl:oneof ccl:*menu-item* :menu-item-title "-")) (browse-item (ccl:oneof ccl:*menu-item* :menu-item-title "SM Structure Browser..." :menu-item-action #'(lambda () (browse-structs :small (wind:y-or-n-dialogue "Make Small browser?"))))) (warn-item (ccl:oneof ccl:*menu-item* :menu-item-title "Warn of Redefinitions" :menu-item-action '(progn (setf *warn-of-redefinitions* (not *warn-of-redefinitions*)) (if *warn-of-redefinitions* (ccl:set-menu-item-check-mark t) (ccl:set-menu-item-check-mark nil))))) (close-type-windows-item (ccl:oneof ccl:*menu-item* :menu-item-title "Close Windows of Type ..." :menu-item-action #'(lambda () (dolist (type (wind:multiple-menu-dialogue (sm:structure-types) "Destroy all Fred windows containing instances of which types?")) (destroy-sm-editor-windows-of-type type))))) (edit-type-item (ccl:oneof ccl:*menu-item* :menu-item-title "Edit Type Definition ..." :menu-item-action #'(lambda () (let ((type (wind:menu-dialogue (cons '|Make New Type| (structure-types)) "Edit Definition of which Structure Type?"))) (if (eq type '|Make New Type|) (edit-type nil) (edit-type type)))))) (reset-type-item (ccl:oneof ccl:*menu-item* :menu-item-title "Reset Structure Type..." :menu-item-action #'(lambda () (let ((type (wind:menu-dialogue (structure-types) "Reset (destroy all instances of) which Structure Type?"))) (reset-type type) (destroy-structure-browsers))))) (destroy-type-item (ccl:oneof ccl:*menu-item* :menu-item-title "Destroy Structure Type..." :menu-item-action #'(lambda () (let ((type (wind:menu-dialogue (structure-types) "Destroy (destroy all instances of and undefine) which Structure Type?"))) (destroy-type type) (setf (get type '$browser-doc-string$) nil) (destroy-SM-editor-windows-of-type type) (destroy-structure-browsers))))) (freelist-item (ccl:oneof ccl:*menu-item* :menu-item-title "Freelist Manager..." :menu-item-action #'(lambda () (let ((types-with-freelists (mapcan #'(lambda (type) (if (freelist type) (list type))) (structure-types)))) (if types-with-freelists (let ((type (wind:menu-dialogue types-with-freelists "The following Structure Types have nonempty Freelists (containing reusable allocated structures). Select one to see its length (with option of flushing), or cancel:"))) (when (wind:y-or-n-dialogue "Type ~S has ~S reusable instances on its Freelist. Do you want to reclaim (gc) them?" type (length (freelist type))) (flush-freelist type) (ccl:gc))) (wind:message-dialogue "No structure type currently has structures allocated on its freelist.")))))) (reset-SM-item (ccl:oneof ccl:*menu-item* :menu-item-title "Reset SM..." :menu-item-action #'(lambda () (if (wind:y-or-n-dialogue "Reset (destroy all instances of) ALL SM Structure types?") (progn (reset-all-types) (destroy-structure-browsers)))))) (destroy-SM-item (ccl:oneof ccl:*menu-item* :menu-item-title "Destroy SM..." :menu-item-action #'(lambda () (if (wind:y-or-n-dialogue "Destroy (destroy all instances of and undefine) ALL SM Structure types?") (progn (dolist (type (structure-types)) (setf (get type '$browser-doc-string$) nil) (destroy-SM-editor-windows-of-type type)) (destroy-all-types) (destroy-structure-browsers)))))) ;; In the next two, we construct paths even though the functions called ;; do the same, since we can use macintosh file dialogues here. (load-type-item (ccl:oneof ccl:*menu-item* :menu-item-title "Load Structure Type..." :menu-item-action #'(lambda () (let* ((type (wind:menu-dialogue (cons "New Type" (structure-types)) "Load from disk instances of which Structure Type?")) (file-path nil)) (if (equal type "New Type") (setq type (read-from-string (wind:get-string-dialogue "Enter the name of the type, including package. ~ (The type must be defined by the file loaded.)")))) (setq file-path (ccl:choose-file-dialog :directory (format nil "~A~A.~A" *default-instance-file-path* type *default-instance-file-type*))) (if (probe-file file-path) (progn ;; Change default path to one given, and record path (setf *default-instance-file-path* (directory-namestring file-path)) (ccl:eval-enqueue `(load-type ',type :path ',file-path))) (wind:message-dialogue "File ~S doesn't seem to exist." (namestring file-path))))))) (save-type-item (ccl:oneof ccl:*menu-item* :menu-item-title "Save Structure Type..." :menu-item-action #'(lambda () (let* ((type (wind:menu-dialogue (structure-types) "Save to disk instances of which Structure Type?")) (file-path (pathname (ccl:choose-new-file-dialog ;; Pathname defaults first to that loaded ;; from, second to file with name of type ;; in path last used for instance access. :directory (let ((prev-path (get type '$SM-instance-path$))) (if prev-path (make-pathname :device (pathname-device prev-path) :directory (pathname-directory prev-path) :name (pathname-name prev-path) :type *default-instance-file-type*) (make-pathname :directory *default-instance-file-path* :name (symbol-name type) :type *default-instance-file-type*))) :prompt (format nil "Save ~A to ..." type)))) (backup-path (make-pathname :host (pathname-host file-path) :device (pathname-device file-path) :directory (pathname-directory file-path) :name (pathname-name file-path) :type "bak")) (instances (instances type))) (multiple-value-bind (compile-p define-type-p specify-instances append-p) (save-type-parameter-dialogue type) (if specify-instances (setf instances (wind:multiple-menu-dialogue instances "Choose the instances of ~S to save to ~S" type (namestring file-path)))) (when (and (not append-p) (probe-file file-path)) (if (probe-file backup-path) (delete-file backup-path)) (rename-file file-path backup-path) (format T "~&;~A backed up to ~A" (namestring file-path) (namestring backup-path))) (setf *default-instance-file-path* (directory-namestring file-path)) ;; Eval-enqueue of save-type dangerous, but compile can be. (save-type type :path file-path :style :pretty-macro :compile nil :define-type define-type-p :instances instances :append append-p) (format T "~&;Instances of ~A saved to ~S" type (namestring file-path)) ;; Editor windows are marked as modified. Destroying them when ;; all is done "unlocks" exit from lisp. (I am trying to make the ;; presence of modified sm:edits windows the indicator that there ;; is in-memory stuff to be saved. To encourage the user to take ;; them as such, I try to be consistent and destroy them when there ;; is nothing to be saved.) (ccl:eval-enqueue `(progn (when ',compile-p (compile-file ,(namestring file-path))) (unless ',specify-instances (destroy-sm-editor-windows-of-type ',type))))))))) (dispose-item (ccl:oneof ccl:*menu-item* :menu-item-title "Hide This Menu" :menu-item-action '(ccl:ask *SM-menu* (ccl:menu-deinstall)))) (SM-menu (ccl:oneof ccl:*menu* :menu-title "SM" :menu-items (list browse-item warn-item close-type-windows-item line-item edit-type-item reset-type-item destroy-type-item freelist-item line-item load-type-item save-type-item line-item reset-SM-item destroy-SM-item line-item dispose-item)))) (ccl:defobfun (ccl:menu-item-update warn-item) () (if *warn-of-redefinitions* (ccl:set-menu-item-check-mark t) (ccl:set-menu-item-check-mark nil))) (ccl:ask SM-menu (ccl:menu-install)) (ccl:ask line-item (ccl:menu-item-disable)) ;; 1.3.1 dumped menu-dispose? (if (and (boundp '*sm-menu*) (typep *sm-menu* ccl:*menu*)) (ccl:ask *sm-menu* (ccl:menu-deinstall))) SM-menu)) (ccl:ask ccl:*tools-menu* (ccl:add-menu-items (ccl:oneof ccl:*menu-item* :menu-item-title "Restore SM Menu" :menu-item-action #'(lambda () (ccl:ask *sm-menu* (unless (ccl:menu-installed-p) (ccl:menu-install))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (provide :SMEDIT) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; EOF 
